Quando se está procurando uma nova leitura, uma das coisas que pode ser observada é a avaliação do livro. De acordo com ela, pode-se ter uma ideia inicial se o livro é bom ou se ele segue uma dinâmica que se está habituado, já que muitas pessoas deram uma nota alta de avaliação. Pensando sobre isso, levantamos o questionamento: seria possível predizer se um livro é bom sem ter acesso a nota da avaliação? Dessa forma pensamos em realizar um modelo para classificar a avaliação de um livro. Para esta tarefa utilizaremos o seguinte conjunto de dados: Goodreads-books| Kaggle e como inspiração para construção do modelo utilizaremos o seguinte guia: Tune xgboost models with early stopping to predict shelter animal status| Julia Silge.
Assim, uma das possibilidades é fazer uma categorização das avaliações dos livros em “Ruim”, “Bom” e ’’Ótimo”, considerando respectivamente os intervalos das notas como, [0, 3.5), [3.5, 4] e (4, 5], e a partir daí predizer a avaliação dos livros utilizando o XGboost. O critério de intervalo para as categorias das notas foi definido subjetivamente ao acaso entre as participantes do grupo, tentando balancear a quantidade de observações que ficariam em cada grupo.
Além disso, como o objetivo é classificar os livros sem olhar as avaliações, as notas não farão parte do modelo, elas serão utilizadas apenas para criar as categorias e estamos supondo que de alguma forma as variáveis como número de páginas, idade do livro, editora, quantidade de notas de avaliações e quantidade de avaliações escritas estão relacionadas com a avaliação do livro.
library(knitr)
opts_chunk$set(message=FALSE,
warning=FALSE,
echo = TRUE,
#results="asis",
cache = TRUE,
dev = "png",
dpi = 500)
#Pacotes necessários
library(tidyverse)
library(tidymodels)
library(lubridate)
library(vip)
library(GGally)
theme_set(theme_light(base_family = "IBMPlexSans"))
# Carregando os dados
livros <- read.csv("./Conjunto de Dados/books.csv",
encoding = "UTF-8",
header = TRUE) %>%
select(-bookID,
-title,
-isbn,
-isbn13) %>%
na.omit()
Análisando o conjunto de dados percebemos que algumas variáveis nos códigos da linguagem estavam em formato de númeração e precisaram ser removidas.
summary(as.factor(livros$language_code))
## 9780674842113 9780851742717 9781563841552 9781593600112 ale
## 1 1 1 1 1
## ara en-CA en-GB en-US eng
## 1 7 214 1408 8908
## enm fre ger gla glg
## 3 144 99 1 1
## grc ita jpn lat msa
## 11 5 46 3 1
## mul nl nor por rus
## 19 1 1 10 2
## spa srp swe tur wel
## 218 1 2 1 1
## zho
## 14
linhas_invalidas_de_language_code<- livros %>%
filter(language_code=="9780674842113"|
language_code=="9780851742717"|
language_code=="9781563841552"|
language_code=="9781593600112"|
language_code=="")
livros <- livros %>%
filter(!(language_code%in%linhas_invalidas_de_language_code$language_code))
rm(linhas_invalidas_de_language_code)
Fazendo o gráfico de barras para ver a variação dessas linguagens, obtemos o seguinte resultado:
livros %>%
ggplot(aes(language_code))+
geom_bar()+
coord_flip()
Como há muito pouca variação linguistica comparado ao grupo inglês, dividiremos a categoria de language_code em duas: inglês e outros.
livros <- livros %>%
mutate(publication_date = mdy(publication_date),
average_rating = as.double(average_rating),
num_pages = as.integer(num_pages),
book_age = year(today())-year(publication_date),
month_publication = as.factor(month(publication_date)),
year_publication = as.factor(year(publication_date)),
language_code = factor(
ifelse(language_code %in% c("enm",
"eng",
"en-US",
"en-GB",
"en-CA"),
"English","Other")
)
) %>%
select(-authors, -publisher) %>%
na.omit()
summary(livros)
## average_rating language_code num_pages ratings_count
## Min. :0.000 English:10539 Min. : 0.0 Min. : 0
## 1st Qu.:3.770 Other : 582 1st Qu.: 192.0 1st Qu.: 104
## Median :3.960 Median : 299.0 Median : 745
## Mean :3.934 Mean : 336.3 Mean : 17945
## 3rd Qu.:4.140 3rd Qu.: 416.0 3rd Qu.: 4996
## Max. :5.000 Max. :6576.0 Max. :4597666
##
## text_reviews_count publication_date book_age month_publication
## Min. : 0.0 Min. :1900-01-01 Min. : 2.00 9 :1278
## 1st Qu.: 9.0 1st Qu.:1998-07-17 1st Qu.: 17.00 10 :1212
## Median : 47.0 Median :2003-03-01 Median : 19.00 1 :1057
## Mean : 542.1 Mean :2000-08-29 Mean : 21.83 4 : 991
## 3rd Qu.: 238.0 3rd Qu.:2005-10-01 3rd Qu.: 24.00 5 : 922
## Max. :94265.0 Max. :2020-03-31 Max. :122.00 6 : 879
## (Other):4782
## year_publication
## 2006 :1700
## 2005 :1260
## 2004 :1069
## 2003 : 931
## 2002 : 798
## 2001 : 656
## (Other):4707
Temos 50% das observações estão entre [0,3.96] e o 1º Q é 3.77, que é bem próximo, mostrando que há uma concentração de avaliações, verificando o histograma dessa variável temos:
livros %>%
ggplot(aes(x=average_rating, after_stat(scaled)))+
geom_histogram(aes(y=..density..),
bins = 15)+
geom_density()+
geom_vline(xintercept = c(3.5,4), color = "green", lty=2)
E conferindo a quantidade de observações menores de 3 temos:
livros %>%
filter(average_rating<3.5) %>%
count()
summary(livros$average_rating)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 3.770 3.960 3.934 4.140 5.000
quantile(livros$average_rating,.67)
## 67%
## 4.07
livros %>%
filter(average_rating>4) %>%
count()
Dessa forma, trabalharemos apenas com três categorias, “Ruim”, “Bom” e ’’Ótimo”, considerando respectivamente os intervalos de nota de [0, 3.5), de [3.5, 4] e de (4, 5], uma vez que pelo histograma é notado a distribuição nas avaliações de 3 a 5.
Sendo assim, nosso conjunto de dados final é composto por três categorias: “Ruim”, “Bom” e ’’Ótimo”. Aplicando no conjunto de dados:
livros <- livros %>%
mutate(
book_rating =
case_when(average_rating<3.5 ~ "Ruim",
average_rating<=4 ~ "Bom",
TRUE ~ "Ótimo")
) %>%
select(-average_rating)
livros %>%
group_by(book_rating) %>%
count()
# Salvando os dados atuais
write.csv(livros,
"./Conjunto de Dados/books_t.csv",
fileEncoding = "UTF-8",
row.names = FALSE)
# Carregando conjunto de dados após a limpeza
livros <- read.csv("./Conjunto de Dados/books_t.csv",
encoding = "UTF-8") %>%
mutate_if(is.character,factor) %>%
mutate(month_publication=factor(month_publication),
year_publication=factor(year_publication),
book_rating=factor(book_rating,
levels = c("Ótimo","Bom","Ruim")))
set.seed(1904, kind = "Mersenne-Twister", normal.kind = "Inversion")
livros_split <- initial_split(livros, prop = .75, strata = book_rating)
livros_treino <- training(livros_split)
livros_teste <- testing(livros_split)
livros_treino %>%
select(where(is.numeric)) %>%
ggpairs(upper = list(continuous = wrap("cor", method = "spearman")))
Dado que identificamos alta correlação entre as variáveis text_reviews_counte rating_count a variável text será removida pois não necessariamente todo mundo que dá uma nota de avaliação também deixa uma avaliação escrita, o que inclusive explica a forte correlação entre essas variáveis, pois certamente todos que deixaram avaliação escrita também deixaram nota, no entanto, consideramos essa medida importante para avaliar se o livro é ótimo ou ruim, supondo que quando um livro for uma dessas duas opções as pessoas façam mais questão de comentar.
Sendo assim, criaremos uma variável proporção:
livros_treino <- livros_treino %>%
mutate(prop_text_reviews = text_reviews_count / ratings_count) %>%
select(-text_reviews_count)
cor(livros_treino$prop_text_reviews,livros_treino$ratings_count,
use = "complete", method = "spearman")
## [1] -0.3605444
Com essa nova variável tivemos uma baixa correlação, assim evitamos a multicolineariedade.
livros_treino %>%
select(where(is.numeric),book_rating) %>%
pivot_longer(-book_rating) %>%
ggplot(.,aes(fill = book_rating)) +
geom_boxplot(aes(y=value)) +
facet_wrap(~ name, scales = "free") +
labs(x="",
y="Valor",
fill = "Classificação\ndo Livro",
title = "Boxplot das variáveis por classificação do livro")+
scale_fill_viridis_d()
Pelos box-plots é notado que as distribuições das classificações de acordo com as variáveis há poucas diferenças entre si.
grafico_otimos_mes_ano <- livros_treino %>%
mutate(book_rating = book_rating == "Ótimo") %>%
group_by(
mes = month_publication,
ano = year_publication
) %>%
summarise(book_rating = mean(book_rating)) %>%
ggplot(aes(mes,ano, fill = book_rating)) +
geom_tile(alpha = .75) +
scale_fill_viridis_c(labels = scales::percent) +
labs(fill = "% livros ótimos" , x="Mês", y="Ano",
title = "Composição dos livros avaliados como: ÓTIMO")+
theme(legend.position = "right");grafico_otimos_mes_ano
É observado que há uma maior avaliação de livros a partir dos anos 80 até em torno do ano de 2012. Nesses anos tiveram muitas avaliações de livros e a porcentagem de avaliação para ótimo está em torno de 25% a 75% em sua maioria.
Verificando a distribuição de livros publicados ao longo dos anos temos:
livros_treino %>%
group_by(
mes = month_publication,
ano = year_publication
) %>%
count() %>%
ggplot(aes(n,ano, fill=mes))+
geom_col()+
geom_hline(yintercept = "1986", color = "blue", lty=2)+
geom_hline(yintercept = "2008", color = "blue", lty=2)+
theme(panel.border = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank())+
labs(x = "Quantidade Publicações",
y = "Ano",
fill = "Mês",
title = "Quantidade de Publicações por Ano")+
scale_fill_viridis_d()
Como o boxplot apresentou muitos outliers e percebemos uma concentração nos dados iremos realizar uns filtros para melhorar a modelagem:
gridExtra::grid.arrange(ncol=2,
livros_treino %>%
ggplot(aes(x=book_age)) +
geom_histogram(bins=30)+
geom_vline(xintercept = quantile(livros_treino$book_age),
color="green", lty=2)+
labs(title = "Histograma book_age",
x="",
y="")
,
livros_treino %>%
ggplot(aes(x=num_pages)) +
geom_histogram(bins=30)+
geom_vline(xintercept = quantile(livros_treino$num_pages),
color="green", lty=2)+
labs(title = "Histograma num_pages",
x="",
y="")
,
livros_treino %>%
ggplot(aes(x=ratings_count)) +
geom_histogram(bins=30)+
geom_vline(xintercept = quantile(livros_treino$ratings_count),
color="green", lty=2)+
labs(title = "Histograma ratings_count",
x="",
y="")
,
livros_treino %>%
ggplot(aes(x=prop_text_reviews)) +
geom_histogram(bins=30)+
geom_vline(xintercept = quantile(livros_treino$prop_text_reviews, na.rm = TRUE),
color="green", lty=2)+
labs(title = "Histograma prop_text_reviews",
x="",
y="")
)
Com os histogramas das variáveis númericas percebemos que a maioria tem uma assimetria a direita, então com isso decidimos aplicar filtros nessas variáveis para diminuir os outliers dos nossos dados. A única variável em que o filtro não será aplicado por não ter a assimetria será a ratings_count.
E agora o novo boxplot com os filtros aplicados:
livros_treino %>%
filter(book_age<40) %>%
filter(num_pages<1000) %>%
filter(ratings_count<1000) %>%
select(where(is.numeric),book_rating) %>%
pivot_longer(-book_rating) %>%
ggplot(.,aes(fill = book_rating)) +
geom_boxplot(aes(y=value)) +
facet_wrap(~ name, scales = "free") +
labs(x="",
y="Valor",
fill = "Classificação\ndo Livro",
title = "Boxplot das variáveis por classificação do livro")+
scale_fill_viridis_d()
Com as mudanças feitas, houve uma diferença notável nas distribuições da idade do livro, número de páginas e avaliações, as amplitudes e variações em comparação aos box-plots anteriores. As contagens de avaliações, na classificação ótimas a amplitude e a variação é maior que as demais, se assemelha a classificação “Bom”, “Ruim” é a que possui mais outliers mas sua amplitude e vaiação é a menor.
Considerando as alterações sofridas no conjunto de dados após a análise exploratória, será necessário carregar novamente o conjunto de dados, bem como gerar novo conjunto de treino e teste:
livros <- read.csv("./Conjunto de Dados/books_t.csv",
encoding = "UTF-8") %>%
mutate(publication_date=as.Date(publication_date),
prop_text_reviews = text_reviews_count / ratings_count,
prop_text_reviews = ifelse(prop_text_reviews %in% c(NaN,Inf), 0, prop_text_reviews),
book_rating=factor(book_rating,
levels = c("Ótimo","Bom","Ruim"))) %>%
select(-month_publication, -year_publication, -text_reviews_count) %>%
filter(book_age<40) %>%
filter(num_pages<1000) %>%
filter(ratings_count<1000)
set.seed(1904, kind = "Mersenne-Twister", normal.kind = "Inversion")
livros_split <- initial_split(livros, prop = .75, strata = book_rating)
livros_treino <- training(livros_split)
livros_teste <- testing(livros_split)
#####Criando Métricas#####
(livros_metricas <- metric_set(accuracy, roc_auc, mn_log_loss))
## # A tibble: 3 x 3
## metric class direction
## <chr> <chr> <chr>
## 1 accuracy class_metric maximize
## 2 roc_auc prob_metric maximize
## 3 mn_log_loss prob_metric minimize
#####Criando Folds#####
set.seed(1989)
(livros_folds <- vfold_cv(livros_treino, strata = book_rating, v=10))
livros_rec <- recipe(book_rating ~ ., data = livros_treino) %>%
themis::step_downsample(book_rating) %>%
step_date(publication_date, features = c("month"),
keep_original_cols = FALSE) %>%
step_dummy(all_nominal_predictors(), one_hot = TRUE) %>%
step_zv(all_numeric_predictors()) %>%
#step_pca(all_predictors(),threshold = .80) %>%
prep()
head(prep(livros_rec) %>%
bake(new_data =NULL))
stopping_spec <-
boost_tree(
trees = 500,
mtry = tune(),
learn_rate = tune(),
stop_iter = tune()
) %>%
set_engine("xgboost", validation = 0.2) %>%
set_mode("classification")
stopping_grid <-
grid_latin_hypercube(
mtry(range = c(5L, 18L)),
learn_rate(range = c(-5, -1)),
stop_iter(range = c(10L, 50L)),
size = 10
)
early_stop_wf <- workflow(livros_rec, stopping_spec)
doParallel::registerDoParallel()
set.seed(2022)
stopping_rs <- tune_grid(
early_stop_wf,
livros_folds,
grid = stopping_grid,
metrics = livros_metricas
)
autoplot(stopping_rs)
show_best(stopping_rs, metric = "mn_log_loss")
stopping_fit <- early_stop_wf %>%
finalize_workflow(select_best(stopping_rs, "mn_log_loss")) %>%
last_fit(livros_split)
stopping_fit
collect_metrics(stopping_fit)
extract_workflow(stopping_fit) %>%
extract_fit_parsnip() %>%
vip(num_features = 15, geom = "point")+
ggtitle("Variáveis mais importantes no modelo")
As variáveis mais importantes para o modelo são os número de páginas, contagem de avaliações, comentários de textos e a idade do livro.
O que faz sentido pois a junção dessas variáveis para fazer uma classificação, É difícil ter muitos livros com muitas páginas, conseguir seguir uma linha de raciocínio e uma trama na qual prenda o leitor. Além disso, quanto mais páginas provavelmente mais caro será o livro.
Principalmente,atualmente, a questão de um livro está sendo muito avaliado, muito divulgado nas redes, faz com que mais pessoas queiram consumir eles, tanto pela curiosidade de saber por que ele é tão bem avaliado e descutido. Em relação a idade
A idade do livro é um fator interessante, há os livros que se tornam clássicos, os que são deixados de lado e os que é possível fazer sucesso mesmo com um certo tempo de publicação.
collect_predictions(stopping_fit) %>%
conf_mat(book_rating, .pred_class) %>%
autoplot(type = "heatmap")+
ggtitle("Mapa de Calor das Predições")
O modelo não foi o melhor, principalmente para avaliar “Ótimo” e “Bom”.
Dos livros classificados como “Ótimo”, o modelo classificou 189 como “Bom” e 146 como “Ruim”.
Dos livros classificados como “Bom”, o modelo classificou 200 como “Ótimo” e 209 como “Ruim”.
collect_predictions(stopping_fit, summarize = FALSE) %>%
roc_curve(book_rating, .pred_class:.pred_Ruim) %>%
ggplot(aes(1 - specificity, sensitivity, color = .level)) +
geom_abline(lty = 2, color = "gray80", size = 1.5) +
geom_path(alpha = 0.8, size = 1) +
coord_equal() +
labs(color = NULL,
title = "Curva ROC Modelo Final")
## Verdadeiro positivo
collect_predictions(stopping_fit, summarize = TRUE) %>%
sens(book_rating, .pred_class)
## Verdadeiro negativo
collect_predictions(stopping_fit, summarize = TRUE) %>%
spec(book_rating, .pred_class)